perm filename UPGETL.NEW[1,JRA] blob sn#022403 filedate 1973-02-01 generic text, type T, neo UTF8
00100	
00150	(DE *CL(C)(UPGETL1 C XYZ1(CONS(CONS @CLAUSES XYZ1)NEWNAME)) )
00200	
00300	(DEFPROP UPGETL 
00400	 (LAMBDA(E N)
00500	  (PROG (C)
00600		(SCANSET)
00700		(START)
00800		(SETQ C (ERRSET (<CLAUSES>) T))
00900		(SCANRESET)
01000		(COND ((OR (NULL C) (NULL (CAR C))) (PRINT (QUOTE LOSSAGE-IN-CLAUSES)) (RETURN NIL)))
01100		(SETQ C (TOP))
01200		(COND ((EQ C (QUOTE EMPTY)) (RETURN NIL)))
01250	(RETURN(UPGETL1 C E N))))EXPR)
01275	(DEFPROP UPGETL1(LAMBDA(C E N)
01287	(PROG(N1 Z Z1 Z2 Z3 ZZ N2)
01300	   AS1  (SETQ Z (CAR C))
01400		(COND ((ATOM Z)
01500		       (COND ((NUMBERP Z) (SETQ N2 (QUOTE CLAUSES))
01600					  (COND ((SETQ Z1 (DOWN Z E)) (SETQ ZZ (APPENDIT ZZ (LIST (CAR Z1)))))
01700						(T (RETURN NIL))))
01800			     ((SETQ Z1 (GETNAME Z N)) (SETQ N2 Z) (SETQ ZZ (APPENDIT ZZ Z1)))
01900			     (T (RETURN NIL))))
02000		      ((EQ (CAR Z) (QUOTE STAT)) (GO AS10))
02100		      ((EQ (CAR Z) (QUOTE FIND)) (GO AS20))
02200		      ((EQ (CAR Z) (QUOTE DSK)) (GO AS30))
02300		      ((SETQ Z1 (GETNAME (CAR Z) N)) (SETQ N2 (CAR Z)) (GO AS2))
02400		      (T (RETURN NIL)))
02500	   AS6  (SETQ C (CDR C))
02600		(COND (C (GO AS1)) (T (RETURN ZZ)))
02700	   AS2  (SETQ Z2 (CADR Z))
02800		(SETQ N1 (CAR Z))
02900		(SETQ Z (CDR Z))
03000		(SETQ Z3 Z1)
03100	   AS2A (COND ((NOT (NUMBERP Z2)) (PRINT (QUOTE NON-NUMERIC-ARG-FOR:)) (PRINC N1) (RETURN NIL)))
03200	   AS3  (SETQ Z2 (SUB1 Z2))
03300		(COND ((ZEROP Z2) (GO AS4)))
03400		(SETQ Z1 (CDR Z1))
03500		(COND (Z1 (GO AS3)) (T (PRINT (QUOTE EXCEEDED-SIZE-OF:)) (PRINC N1) (RETURN NIL)))
03600	   AS4  (COND
03700		 ((NOT (HERE (CAR Z1))) (PRINT N1)
03800					(PRINC (QUOTE / ))
03900					(PRINC (CAR Z))
04000					(PRINC (QUOTE / ))
04100					(PRINC (QUOTE HAS-BEEN-DELETED))
04200					(RETURN NIL)))
04300		(SETQ ZZ (APPENDIT ZZ (LIST (CAR Z1))))
04400		(SETQ Z (CDR Z))
04500		(COND (Z (SETQ Z1 Z3) (SETQ Z2 (CAR Z)) (GO AS2A)))
04600		(GO AS6)
04700	   AS10 (SETQ N2 (QUOTE INSERT))
04800		(SETQ ZZ (APPENDIT ZZ (SET3 (SETUP (CNF (FIXQFF (CDR Z)))))))
04900		(GO AS6)
05000	   AS20 (SETQ N2 (QUOTE MATCHES))
05100		(SETQ Z (MAPIT (CADR Z) (LIST (QUOTE FUNCTION) (LIST (QUOTE LAMBDA) (QUOTE (C)) (CADDR Z))) N))
05200		(COND ((NULL Z) (GO AS6)) (T (GO AS31)))
05300	   AS30 (SETQ N2 (QUOTE INPUT))
05400		(SETQ ZIN (CDR Z))
05500		(COND
05600		 ((NULL (ERRSET (EVAL (LIST (QUOTE INPUT) (QUOTE DSK:) ZIN)))) (PRINT (QUOTE CONTINUING)) (GO AS6)))
05700		(INC T)
05800		(SETQ Z (INCLAUSES))
05900		(INC NIL)
06000		(COND ((NULL Z) (RETURN NIL)))
06100	   AS31 (SETQ ZZ (APPENDIT ZZ Z))
06200		(GO AS6))) 
06300	EXPR)